' NOTE: "Microsoft DAO 3.51 Object Library" MUST be referenced.
' To do so, select Project > References from the menu. In the
' resulting dialog box select "Microsoft DAO 3.51 Object Library"
' and click OK.
' This stops an hWnd from being updated. It should speed up
' our listbox/listview population considerably. Pass it an hWnd
' to lock, to unlock, pass zero (0).
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Function FileExists(Optional ByVal sFileName As Variant, Optional ByVal sPath As Variant) As Boolean
' By PCC MikeD
' Function: FileExists
'
' Checks whether sFileName exists in sPath.
' If only sPath is passed to the function,
' the existance of sPath is checked.
' Returns either 'True' or 'False'
On Error GoTo Oops
If IsMissing(sPath) Then
'Only a file name was passed.
If Len(Dir$(sFileName)) Then FileExists = True
Else
'A directory was passed
'Append a backslash to the pathname, if necessary.
If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"
If IsMissing(sFileName) Then
'Directory was passed, but not a file, so determine if
'the directory exists
If Len(Dir$(sPath, vbDirectory)) Then FileExists = True
Else
'Both a directory and a file were passed, so determine
'if the file exists in the specified directory.
If Len(Dir$(sPath & sFileName)) Then FileExists = True
End If
End If
Exit Function
Oops:
Exit Function
End Function
Public Function LoadList(ByVal sFileName As String, Optional lbList As ListBox, Optional lvList As ListView) As Boolean
' Make sure a list was passed to us
If TypeName(lbList) = "Nothing" And TypeName(lvList) = "Nothing" Then LoadList = False: Exit Function
Dim fileNum As Integer ' freefile
Dim i As Long ' loop counter
Dim j As Integer ' loop counter
Dim sDelimiter As String
Dim fileInput As String
Dim fileArray As Variant
Dim itemArray As Variant
Dim xItem As ListItem
sDelimiter = "$^e&p%q#!" ' We want something extremely unique to delimit
' each of the subitems if we get a listview. This
' should do it, but you can change this here
' if necessary
' Find a free file number to use
fileNum = FreeFile
If Not FileExists(sFileName) Then Exit Function
Open sFileName For Input As fileNum
i = FileLen(sFileName)
' The file passed doesn't contain any data. Exit the function
If i = 0 Then Close fileNum: LoadList = False: Exit Function
fileInput = Input(i, fileNum)
Close fileNum
' If the user passes us a listview, but the delimiter is not present in the file,
' then the file was not saved using the sister function, SaveList. Exit.
If (Not TypeName(lvList) = "Nothing") And (InStr(fileInput, sDelimiter) = 0) Then LoadList = False: Exit Function
fileArray = Split(fileInput, vbCrLf)
If (Not TypeName(lbList) = "Nothing") Then ' A listbox was passed, loop through it
For i = 0 To UBound(fileArray)
lbList.AddItem fileArray(i)
Next i ' = 0 To UBound(fileArray)
Else ' A listview was passed. loop through it and it's subitems
For i = 0 To UBound(fileArray)
If (Not TrimNull(fileArray(i)) = "") Then
itemArray = Split(fileArray(i), sDelimiter)
For j = 0 To UBound(itemArray)
Select Case j
Case 0
Set xItem = lvList.ListItems.Add(, , itemArray(j))
Case 1
xItem.Tag = itemArray(j)
Case 2
If itemArray(j) = "True" Then xItem.Checked = True
Case Else
xItem.SubItems(j - 2) = itemArray(j)
End Select ' j
Next j ' = 0 To UBound(itemArray)
End If ' (Not TrimNull(hdrArray(i)) = "")
Next i ' = 0 To UBound(fileArray)
End If ' (TypeName(lbList) = "Nothing")
LoadList = True
End Function
Public Function SaveList(ByVal sFileName As String, Optional lbList As ListBox, Optional lvList As ListView, Optional ByVal sCriteria As String, Optional ByVal iSubItem As Integer, Optional ByVal useTag As Boolean = False, Optional matchCase As Boolean = True) As Boolean
' Make sure a list was passed to us
If TypeName(lbList) = "Nothing" And TypeName(lvList) = "Nothing" Then SaveList = False: Exit Function
Dim fileNum As Integer
Dim i As Long
Dim sDelimiter As String
Dim curItem As String
sDelimiter = "$^e&p%q#!" ' We want something extremely unique to delimit
' each of the subitems if we get a listview. This
' should do it, but you can change this here
' if necessary
' Find a free file number to use
fileNum = FreeFile
If FileExists(sFileName) Then Kill (sFileName)
Open sFileName For Append As fileNum
If Not TypeName(lbList) = "Nothing" Then ' A listbox was passed, loop through it
For i = 0 To lbList.ListCount - 1
If (sCriteria <> "") Then
If (matchCase = True) Then
If InStr(lbList.List(i), sCriteria) Then Print #fileNum, lbList.List(i)
Else
If InStr(LCase(lbList.List(i)), LCase(sCriteria)) Then Print #fileNum, lbList.List(i)
End If ' (matchCase = True)
Else
Print #fileNum, lbList.List(i)
End If ' (sCriteria <> "")
Next i ' i = 0 To lbList.ListCount - 1
Else ' A listview was passed. loop through it and it's subitems
For i = 1 To lvList.ListItems.Count
If (sCriteria <> "") Then
If (useTag = True) Then
curItem = lvList.ListItems.item(i).Tag
If (matchCase = True) Then
If curItem Like sCriteria Then Print #fileNum, GetListItem(lvList.ListItems.item(i), sDelimiter)
Else
If LCase(curItem) Like LCase(sCriteria) Then Print #fileNum, GetListItem(lvList.ListItems.item(i), sDelimiter)
End If ' (matchCase = True)
Else
' If iSubItem is 0 then use the item.text instead
If iSubItem <> 0 Then curItem = lvList.ListItems.item(i).SubItems(iSubItem) Else curItem = lvList.ListItems.item(i).Text
If (matchCase = True) Then
If curItem Like sCriteria Then Print #fileNum, GetListItem(lvList.ListItems.item(i), sDelimiter)
Else
If LCase(curItem) Like LCase(sCriteria) Then Print #fileNum, GetListItem(lvList.ListItems.item(i), sDelimiter)
(.txt)